Just Call Me Internet/Just Call Me Internet.iso/prog/atari/m2/cat3src/magic/i/mtrsc.org

Modula Implementation | 1997-10-26 | 10.0 KB | 340 lines

(*----------------------------------------------------------------------*
 *                                                                      *
 *  MAGICTOOLS   Modula's  All purpose  GEM  Interface  Cadre  Toolbox  *
 *               ÿ         ÿ            ÿ    ÿ          ÿ               *
 *----------------------------------------------------------------------*
 * Version 3.30  02.02.1992     (C)90/91/92 by Peter Hellinger Software *
 *----------------------------------------------------------------------*
 *            Dieses Modul ist urheberrechtlich geschtzt.              *
 *                                                                      *
 * Die Ver”ffentlichung des Quelltextes oder Teilen daraus, sowie die   *
 * Verbreitung des bersetzten, nicht gelinkten Codes in schriftlicher, *
 * oder maschinenlesbarer Form, insbesondere in Zeitschriften, Mail-    *
 * boxen oder anderen Medien bedarf der ausdrcklichen schriftlichen    *
 * Einverst„ndnisserkl„rung des Autors.                                 *
 *                                                                      *
 * Die Verbreitung des Moduls als Teil eines gelinkten Programms ist    *
 * fr Lizenznehmer ausdrcklich erlaubt!  Der Autor beh„lt sich das    *
 * Recht vor, diese Erlaubnis jederzeit und ohne Angaben von Grnden zu *
 * widerrufen.                                                          *
 *----------------------------------------------------------------------*)

IMPLEMENTATION MODULE mtRsc;

(*----------------------------------------------------------------------*
 * Int. Vers | Datum    | Name | Žnderung                               *
 *-----------+----------+------+----------------------------------------*
 *  3.00     | 18.01.92 |  Hp  |                                        *
 *  3.01     | 21.01.92 |  Hp  | RelocRsc gefixt.                       *
 *  3.02     | 03.02.92 |  Hp  | Routinen optimiert                     *
 *----------------------------------------------------------------------*)



(* IMPLEMENTATION FšR  >>> Megamax-Modula-2 <<< *)
(*                                              *)
(*$R-   Range-Checks                            *)
(*$S-   Stack-Check                             *)
(*                                              *)
(*----------------------------------------------*)








FROM Storage IMPORT ALLOCATE, DEALLOCATE;




FROM MagicSys   IMPORT  Nil, Null, Bit0, Bit1, Bit2, Bit3, Bit4, Bit5, Bit6,
                        Bit7, Bit8, Bit9, Bit10, Bit11, Bit12, Bit13, Bit14,
                        Bit15, LOC, Byte, ByteSet, sWORD, sINTEGER, sCARDINAL,
                        sBITSET, lINTEGER, lCARDINAL, lWORD, lBITSET,
                        CastToChar, CastToByte, CastToByteset, CastToInt,
                        CastToCard, CastToBitset, CastToWord, CastToLInt,
                        CastToLCard, CastToLBitset, CastToLWord, CastToAddr,
                        TosVersion, Accessory, Basepage, SysHeader, TosDate;






FROM SYSTEM             IMPORT  ADDRESS, TSIZE;
FROM MagicAES           IMPORT  AESPB, RsrcLoad, RsrcFree, RsrcGaddr, RsrcSaddr,
                                RsrcObfix, ShelFind, GBOX, GTEXT, GBOXTEXT,
                                GIMAGE, GPROGDEF, GIBOX, GBUTTON, GBOXCHAR,
                                GSTRING, GFTEXT, GFBOXTEXT, GICON, GTITLE;
FROM MagicStrings       IMPORT  Assign;
FROM mtAppl             IMPORT  InstallTermproc, MouseOn, MouseOff, MouseBusy,
                                MouseArrow, StoreMouse, RestoreMouse;

                        IMPORT  MagicAES, MagicTypes, mtUtils;

CONST   cRel = 0;


TYPE    RESOURCE =      POINTER TO Resource;
        Resource =      RECORD
                         addr:  ADDRESS;
                         flags: sBITSET;
                         next:  RESOURCE;
                         last:  RESOURCE;
                        END;

VAR     RscList:        RESOURCE;


PROCEDURE NewRsc (rtree: ADDRESS; mode: sBITSET): RESOURCE;
VAR p, q: RESOURCE;
BEGIN
 IF RscList = NIL THEN
  ALLOCATE (RscList, TSIZE(Resource));
  IF RscList # NIL THEN
   RscList^.addr:= rtree;
   RscList^.flags:= mode;
   RscList^.next:= NIL;
   RscList^.last:= NIL;
  END;
  RETURN RscList;
 ELSE
  p:= RscList;
  WHILE p^.next # NIL DO  p:= p^.next;  END;
  ALLOCATE (q, TSIZE(Resource));
  IF q # NIL THEN
   q^.addr:= rtree;
   q^.flags:= mode;
   q^.last:= p;
   q^.next:= NIL;
   p^.next:= q;
  END;
  RETURN q;
 END;
END NewRsc;

PROCEDURE LoadRsc (REF name: ARRAY OF CHAR; VAR rsc: RESOURCE): BOOLEAN;
VAR path: ARRAY [0..255] OF CHAR;
    load: BOOLEAN;
    adr:  ADDRESS;
BEGIN
 StoreMouse;  MouseBusy;
 Assign (name, path);
 ShelFind (path);
 adr:= AESPB.cbPglobal^.apPtree;
 AESPB.cbPglobal^.apPtree:= Null;
 load:= RsrcLoad (path);
 RestoreMouse;
 IF load = FALSE THEN
  AESPB.cbPglobal^.apPtree:= adr;  rsc:= NIL;  RETURN FALSE;
 END;
 rsc:= NewRsc (AESPB.cbPglobal^.apPtree, {});
 RETURN rsc # NIL;
END LoadRsc;

PROCEDURE RelocRsc (address: ADDRESS; VAR rsc: RESOURCE): BOOLEAN;
CONST MaxObject = MAX (sINTEGER);
VAR   rshdr:    POINTER TO MagicTypes.RSHDR;
      base:     mtUtils.tObjcTree;
      tree:     POINTER TO ARRAY [0..MaxObject] OF mtUtils.tObjcTree;
      string:   POINTER TO ARRAY [0..MaxObject] OF MagicAES.PtrSTRING;
      fimage:   POINTER TO ARRAY [0..MaxObject] OF ADDRESS;
      ted:      POINTER TO ARRAY [0..MaxObject] OF MagicAES.TEDINFO;
      icon:     POINTER TO ARRAY [0..MaxObject] OF MagicAES.ICONBLK;
      image:    POINTER TO ARRAY [0..MaxObject] OF MagicAES.BITBLK;
      c, typ:   sCARDINAL;

 PROCEDURE Lowbyte (value: sINTEGER): sCARDINAL;
 VAR t: RECORD
         CASE x: sCARDINAL OF
          0: int: sINTEGER;|
          1: b2: CHAR; b1: CHAR;|
         END;
        END;
 BEGIN
  t.int:= value;  RETURN  ORD (t.b1);
 END Lowbyte;

BEGIN
 rshdr:= address;
 WITH rshdr^ DO

  (* Trees relozieren *)
  IF rshNtree > 0 THEN
   tree:= address + CastToAddr (rshTrindex);
   FOR c:= 0 TO rshNtree - 1 DO
    tree^[c]:= address + CastToAddr (tree^[c]);
   END;
  END;

  (* FreeStrings relozieren *)
  IF rshNstring > 0 THEN
   string:= address + CastToAddr (rshString);
   FOR c:= 0 TO rshNstring - 1 DO
    string^[c]:= address + CastToAddr (string^[c]);
   END;
  END;

  (* FreeImages relozieren *)
  IF rshNimages > 0 THEN
   fimage:= address + CastToAddr (rshFrimg);
   FOR c:= 0 TO rshNimages - 1 DO
    fimage^[c]:= address + CastToAddr (fimage^[c]);
   END;
  END;

  (* Objcspec relozieren *)
  IF rshNobs > 0 THEN
   base:= address + CastToAddr (rshObject);
   FOR c:= 0 TO rshNobs - 1 DO
    WITH base^[c] DO
     typ:= Lowbyte (obType);
     IF (typ # GBOX) AND (typ # GIBOX) AND (typ # GBOXCHAR) AND
        (typ # GPROGDEF) THEN
      obSpec.address:= address + obSpec.address;
     END; (* IF *)
    END; (* WITH *)
    RsrcObfix (base, c);
   END; (* FOR *)
  END; (* IF rshNobs *)

  (* Ted-Objects relozieren *)
  IF rshNted > 0 THEN
   ted:= address + CastToAddr (rshTedinfo);
   FOR c:= 0 TO rshNted - 1 DO
    WITH ted^[c] DO
     tePtext:=  address + CastToAddr (tePtext);
     tePtmplt:= address + CastToAddr (tePtmplt);
     tePvalid:= address + CastToAddr (tePvalid);
    END; (* WITH *)
   END;
  END;

  (* IconObjects relozieren *)
  IF rshNib > 0 THEN
   icon:= address + CastToAddr (rshIconblk);
   FOR c:= 0 TO rshNib - 1 DO
    WITH icon^[c] DO
     ibPmask:= address + ibPmask;
     ibPdata:= address + ibPdata;
     ibPtext:= address + ibPtext;
    END;
   END;
  END;

  (* ImageObjects relozieren *)
  IF rshNbb > 0 THEN
   image:= address + CastToAddr (rshBitblk);
   FOR c:= 0 TO rshNbb - 1 DO
    WITH image^[c] DO  biData:= address + biData;  END;
   END;
  END;

 END; (* WITH *)

 AESPB.cbPglobal^.apPtree:= tree;
 rsc:= NewRsc (tree, {cRel});
 RETURN rsc # NIL;
END RelocRsc;

PROCEDURE FreeRsc (VAR rsc: RESOURCE);
VAR old: ADDRESS;
BEGIN
 IF rsc # NIL THEN
  old:= AESPB.cbPglobal^.apPtree;
  AESPB.cbPglobal^.apPtree:= rsc^.addr;
  IF NOT (cRel IN rsc^.flags) THEN  RsrcFree;  END;
  IF old # rsc^.addr THEN
   AESPB.cbPglobal^.apPtree:= old;
  ELSE
   IF rsc^.last # NIL THEN
    AESPB.cbPglobal^.apPtree:= rsc^.last^.addr;
   ELSIF rsc^.next # NIL THEN
    AESPB.cbPglobal^.apPtree:= rsc^.next^.addr;
   ELSE
    AESPB.cbPglobal^.apPtree:= Null;
   END;
  END;
  IF rsc^.last # NIL THEN
   rsc^.last^.next:= rsc^.next;
  ELSE
   RscList:= rsc^.next;
  END;
  DEALLOCATE (rsc, 0);
 END;
END FreeRsc;

PROCEDURE FreeAll;
VAR p: RESOURCE;
BEGIN
 IF RscList # NIL THEN
  p:= RscList;
  WHILE p # NIL DO
   AESPB.cbPglobal^.apPtree:= p^.addr;
   IF NOT (cRel IN p^.flags) THEN  RsrcFree;  END;
   p:= p^.next;
  END;
  AESPB.cbPglobal^.apPtree:= Null;
  RscList:= NIL;
 END;
END FreeAll;

PROCEDURE GaddrRsc (rsc: RESOURCE; type, item: INTEGER): ADDRESS;
VAR old, ret: ADDRESS;
BEGIN
 IF rsc # NIL THEN
  old:= AESPB.cbPglobal^.apPtree;
  AESPB.cbPglobal^.apPtree:= rsc^.addr;
  ret:= RsrcGaddr (type, item);
  AESPB.cbPglobal^.apPtree:= old;
  RETURN ret;
 END;
 RETURN NIL;
END GaddrRsc;

PROCEDURE SaddrRsc (rsc: RESOURCE; type, item: INTEGER; tree: ADDRESS);
VAR old: ADDRESS;
BEGIN
 IF rsc # NIL THEN
  old:= AESPB.cbPglobal^.apPtree;
  AESPB.cbPglobal^.apPtree:= rsc^.addr;
  RsrcSaddr (type, item, tree);
  AESPB.cbPglobal^.apPtree:= old;
 END;
END SaddrRsc;

PROCEDURE ObfixRsc (rsc: RESOURCE; tree: ADDRESS; object: INTEGER);
VAR old: ADDRESS;
BEGIN
 IF rsc # NIL THEN
  old:= AESPB.cbPglobal^.apPtree;
  AESPB.cbPglobal^.apPtree:= rsc^.addr;
  RsrcObfix (tree, object);
  AESPB.cbPglobal^.apPtree:= old;
 END;
END ObfixRsc;

PROCEDURE GetRscHeader (rsc: RESOURCE; VAR hdr: RSXHDR);
(* Liefert den RscHeader im langen Format *)
END GetRscHeader;

VAR init : sINTEGER;

PROCEDURE InitMtRsc();
BEGIN
 IF init # 31024
 THEN
   RscList:= NIL;
   InstallTermproc (FreeAll);
   init := 31024
 END;
END InitMtRsc;

BEGIN
  init := 0;
  InitMtRsc();
END mtRsc.